Just Call Me Internet/Just Call Me Internet.iso/com/computer/psion_ft/source.gfa/psion_ft.gfa

GFA-BASIC Atari | 1994-08-07 | 25.7 KB | 1,016 lines

' #######################################################################
' Programm-Name       : PSION-File-Transfer / PSION_FT.PRG
' erstes Erstelldatum : 19.08.93  (Version 0.1)
' Art des Programmes  : Rechnerkopplung
' Autor               : Michael Weigand, Wiener Allee 139, 2300 Kiel 14
' Sprache             : GFA-Basic V3.5E
' ------------------------------------------------------------------------
' Hinweis             : Dieser Quellcode wird ohne jegliche Gew„hrleistung
'                       im Mausnetz ver”ffentlicht.
'                       Teile des Quelltextes drfen in eigenen Programmen
'                       eingesetzt werden.
'                       Jegliche kommerzielle Nutzung von PSION_FT oder
'                       von Teilen dieser Software ist untersagt!
' ------------------------------------------------------------------------
'
$m60000
' --- Speicher reservieren:
'
' --- fr gepatchte GFA3BLIB, hier wohl berflssig, da keine VDI_Ausgabe
CLIP OFF
'
' --- bin ich ein ACC oder ein PRG?
IF LPEEK(BASEPAGE+&H24)=0
  acc!=TRUE
  '
  ON BREAK CONT
  '
  ' ap_id&=DPEEK(LPEEK(GB+4)+4)
  ap_id&=APPL_INIT()
  ~MENU_REGISTER(ap_id&,"  PSION-FT")
  '
ELSE
  acc!=FALSE
  '
  ON BREAK GOSUB rsc_ausgang               ! definierter Abbruch
  ON ERROR GOSUB error
  '
  RESERVE 40000+18*1024
  ' - 8kB sollten fr Variablen/Felder reichen
  ' - 32 kB fr Fileselect,Alert,usw.
  ' - 18*1024 Puffer bei HD
  '
ENDIF
'
windup_count&=0         ! Kontrolle der beg-update/end_update
'
' Pfad fr RSC- und INF-Datei
cur_drive&=FN getdrv
path$=CHR$(cur_drive&+64)
IF acc!
  path$=path$+":\"      ! Hauptebene, wo sonst
ELSE
  path$=path$+":"+DIR$(0)
  IF LEN(path$)=2
    ' Hauptebene
    path$=path$+"\"
  ENDIF
  IF RIGHT$(path$)<>"\"
    path$=path$+"\"
  ENDIF
ENDIF
'
' --- Message-Buffer
DIM nachricht%(3)
'
@init
'
' --- aus die Maus
~GRAF_MOUSE(0,0)
'
DO
  IF acc!
    ~EVNT_MESAG(nachricht%(0))
  ENDIF
  IF MENU(1)=40 OR (NOT acc!)
  error_resume_ziel:                       ! Ein RESUME macht hier weiter
    @main
    IF windup_count&<>0
      ALERT 3,"WIND_UPDATE-Fehler: "+STR$(windup_count&),1," OK ",dummy&
    ENDIF
  ENDIF
  '
  EXIT IF NOT acc!
LOOP
'
@rsc_ausgang                  ! aus die Maus
'
' ##########################################################################
'
PROCEDURE init
  '
  LOCAL sysbase%
  '
  ' --- mach mir die Maus
  @div_maus
  ' ~GRAF_MOUSE(255,VARPTR(glb_disc$))
  DEFMOUSE glb_disc$
  '
  ' --- einige "Konstanten" :
  glb_ok$=" OK "                           ! Button-Text
  glb_cancel$="Abbruch"
  '
  ' --- Dateien zu TERM2000:
  glb_rsc_file$="PSION_FT.RSC"
  glb_info_file$=path$+"PSION_FT.INF"            ! Info-Datei
  '
  ' --- die RSC-Datei laden
  @rsc_data
  @rsc_init
  '
RETURN
> PROCEDURE main
  '
  @info_load                    ! Info-Datei lesen
  '
  @main_dialog                ! Dialog
  '
  @info_save                    ! Info_Datei sichern
  '
RETURN
' #########################################################################
' e_ Empfangs-  s_ Senderoutinen
' ----------------------------------------------------------------------------
> PROCEDURE empfangen
  '
  ' Daten werden vom Sharp empfangen
  '
  LOCAL e_ch&                            ! empfangenes Zeichen
  LOCAL e_count%
  LOCAL e_file$                          ! Pfad u. Name Zieldatei
  '
  ' --- Empfangspuffer berprfen
  i%=0
  IF INP?(1)                         ! wenn Zeichen anliegt
    alert$="Im Empfangspuffer befinden|sich noch einige Zeichen!"
    alert$=alert$+"|Soll der Puffer gel”scht|werden?"
    ALERT 2,alert$,1," JA |NEIN",ret%
    IF ret%=1
      WHILE INP?(1)
        INC i%
        VOID INP(1)
        message(STR$(i%),TRUE)
      WEND
      ALERT 1,"Sollte ab jetzt Empfang|nicht mehr m”glich sein,|bitte booten!",1,glb_ok$,dummy|
      ALERT 1,"Es ist halt nur|'ne Testversion!",1,"Sorry",dummy|
    ENDIF
  ENDIF
  '
  glb_undo!=FALSE                        ! kein Abbruch
  '
  f_msg$="Datei empfangen"
  @fileselect(f_msg$,path$+"*.*","",e_file$)  ! Zieldatei ausw„hlen
  ' FILESELECT #f_msg$,"path$+*.*","",e_file$  ! Zieldatei ausw„hlen
  IF e_file$<>"" AND RIGHT$(e_file$,1)<>"\"    ! nicht Abbruch gew„hlt
    '
    OPEN "i",#1,"STD:"                    ! serielle Schnittstelle ”ffnen
    '
    OPEN "o",#2,e_file$                  ! Datei auf Disk ”ffnen (schreiben)
    e_ch&=0                              ! Zeichenvariable initialisieren
    '
    ON MENU KEY GOSUB div_undo             ! Abfrage der UNDO-Taste
    '
    ~GRAF_MOUSE(255,VARPTR(glb_disc$))             ! Biene
    e_count%=0                           ! Zeichenz„hler
    '
    ' --- TimeOut fr erstes Zeichen
    t%=TIMER
    i&=0
    DO
      '
      ON MENU                            ! Ereignisabfrage f. UNDO-Taste
      EXIT IF glb_undo!=TRUE                 ! Abbruch durch Benutzer
      IF INP?(1)                         ! wenn Zeichen anliegt
        ' --- TimeOut neu starten
        t%=TIMER
        '
        e_ch&=INP(#1)                    !   Zeichen in Variable in%
        '
        PRINT #2;CHR$(e_ch&);      !   Zeichen in Datei schreiben
        '
        INC i&
        IF i&>49
          msg$=STR$(e_count%)+" Bytes empfangen"
          message(msg$,TRUE)
          i&=0
        ENDIF
        '
        INC e_count%
        '
      ENDIF
      '
      time%=(TIMER-t%)/200
      ' TimeOut nach 10 Sekunden
      IF time%>=10
        timeout!=TRUE
      ELSE
        timeout!=FALSE
      ENDIF
      EXIT IF timeout!=TRUE
      '
    LOOP
    '
    CLOSE                                ! Kanal 1 und 2 schliessen
    ~GRAF_MOUSE(0,0)                           ! Pfeil
    '
    IF timeout!=TRUE
      m_msg$="Abbruch nach Timeout!"
      message(m_msg$,TRUE)
      ~EVNT_TIMER(1000)
    ENDIF
    '
    IF glb_undo!=FALSE
      m_msg$=STR$(e_count%)+" Zeichen empfangen."
    ELSE
      m_msg$="Empfang abgebrochen !"
    ENDIF
    message(m_msg$,FALSE)
    '
  ENDIF
  '
RETURN
> PROCEDURE senden
  '
  ' Daten werden zum Sharp gesendet
  '
  LOCAL s_c&                             ! zu sendendes Zeichen
  LOCAL s_file$                          ! Pfad u. Name fr Zieldatei
  LOCAL s_count%
  '
  glb_undo!=FALSE                        ! kein Abbruch durch UNDO-Taste
  glb_error!=FALSE                       ! kein Abbruch durch illegales Zeichen
  '
  f_msg$="Datei senden"
  @fileselect(f_msg$,path$+"*.*","",s_file$)  ! Quelldatei ausw„hlen
  ' FILESELECT #f_msg$,path$+"*.*","",s_file$  ! Quelldatei ausw„hlen
  file_exist(s_file$,ret!)
  IF s_file$<>"" AND ret!=TRUE      ! Abbruch gew„hlt ?
    '
    ' beg_update
    '
    ON MENU KEY GOSUB div_undo             ! Abfrage der UNDO-Taste
    '
    ' so muž laut Atari die Dateil„nge ermittelt werden
    OPEN "i",#2,s_file$
    filelen%=LOF(#2)
    CLOSE #2
    '
    '    OPEN "",#1,"AUX:"                    ! serielle Schnittstelle ”ffnen
    OPEN "i",#2,s_file$
    '
    ~GRAF_MOUSE(255,VARPTR(glb_disc$))                           ! Biene
    '
    t%=TIMER
    s_count%=0
    i&=0
    REPEAT
      ON MENU                            ! Ereignisabfrage ( fr UNDO )
      EXIT IF glb_undo!=TRUE             ! Abbruch durch Benutzer
      '
      IF OUT?(1)
        ' --- TimeOut neu starten
        t%=TIMER
        '
        s_c&=INP(#2)
        ~BIOS(3,1,s_c&)
        '
        INC i&
        IF i&>49
          msg$=STR$(s_count%)+" Bytes gesendet"
          message(msg$,TRUE)
          i&=0
        ENDIF
        '
        INC s_count%
      ENDIF
      '
      time%=(TIMER-t%)/200
      ' TimeOut nach 10 Sekunden
      EXIT IF time%>=10
      '
    UNTIL s_count%=filelen%
    '
    CLOSE                             ! Kanal 1 und 2 schliessen
    ~GRAF_MOUSE(0,0)                        ! Pfeil
    '
    IF glb_undo!=FALSE      ! wenn alles in Ordnung ist
      m_msg$=STR$(s_count%)+" Zeichen gesendet."
    ELSE
      m_msg$="šbertragung abgebrochen !!!"
    ENDIF
    message(m_msg$,FALSE)
    '
    ' end_update
    '
  ENDIF
  '
RETURN
> PROCEDURE rs_232
  '
  ' Setzen der Parameter, falls diese gesetzt werden sollen
  '
  LOCAL baud$
  '
  VOID XBIOS(15,glb_baud&,2,-1,-1,-1,-1)
  SELECT glb_baud&
  CASE 0
    baud$="19200"
  CASE 1
    baud$="9600"
  CASE 2
    baud$="4800"
  CASE 3
    baud$="3600"
  CASE 4
    baud$="2400"
  CASE 5
    baud$="2000"
  CASE 6
    baud$="1800"
  CASE 7
    baud$="1200"
  CASE 8
    baud$="600"
  CASE 9
    baud$="300"
  CASE 10
    baud$="200"
  CASE 11
    baud$="150"
  CASE 12
    baud$="134"
  CASE 13
    baud$="110"
  CASE 14
    baud$="75"
  CASE 15
    baud$="50"
  DEFAULT
    ALERT 3,"Fehler bei Baudrateneinstellung",1,glb_ok$,dummy&
    '  glb_baud&=glb_system&
  ENDSELECT
  '
  ' die OB_-Funktionen lassen den Linker abstrzen !?!
  '  CHAR{{OB_SPEC(glb_maindial_adr%,bbaud%)}}=baud$
  ' primitiver Ersatz dafr
  rsrc_obtxt_set(4,6,baud$)     ! Text-Object Nr. 4, L„nge 6 Zeichen
  '
  '
RETURN
> PROCEDURE div_undo
  '
  ' Wird w„hrend der šbertragung eine Taste gedrckt, so wird hier geprft,
  ' ob es die UNDO-Taste war. Wenn ja, wird das Abbruch-Flag auf TRUE gesetzt.
  '
  IF HEX$(MENU(14)/&HFF)="61"            ! Scan-Code der Taste UNDO = H61
    glb_undo!=TRUE
  ELSE
    glb_undo!=FALSE
  ENDIF
  '
RETURN
' #### Functions ##########################################################
> FUNCTION getdrv
  '
  IF acc!       ! _bootdev
    RETURN DPEEK(&H446)+1
  ELSE
    RETURN GEMDOS(&H19)+1
  ENDIF         ! akt. LW
ENDFUNC
> FUNCTION mfree
  ' --- Freier Speicher in MB ---
  RETURN GEMDOS(72,L:-1)/1024/1024
ENDFUNC
' #########################################################################
' info_
' ---------------------------------------------------------------------------
> PROCEDURE info_save
  '
  ' ~GRAF_MOUSE(255,VARPTR(glb_disc$))
  DEFMOUSE glb_disc$
  '
  OPEN "o",#1,glb_info_file$
  ' beg_update
  PRINT #1,glb_baud&
  ' end_update
  CLOSE #1
  '
  ~GRAF_MOUSE(0,0)
  '
RETURN
> PROCEDURE info_load
  '
  LOCAL info_ext$                        ! Datei-Extension
  '
  ' ~GRAF_MOUSE(255,VARPTR(glb_disc$))
  DEFMOUSE glb_disc$
  '
  ' --- Default-Settings:
  glb_baud&=1
  '
  ' --- .INF-Datei auswerten:
  file_exist(glb_info_file$,f_exist!)
  '
  IF f_exist!
    OPEN "i",#1,glb_info_file$
    ' beg_update
    INPUT #1,glb_baud&
    ' end_update
    CLOSE #1
    '
  ELSE
    ALERT 1,"PSION_FT.INF nicht gefunden!|PSION-FT verwendet deshalb|die Standardeinstellungen.",1," OK ",dummy&
  ENDIF
  '
  ' --- Und Baudrate einstellen
  rs_232
  '
  ~GRAF_MOUSE(0,0)
  '
RETURN
' ############################################################################
> PROCEDURE div_maus
  ' --- Neue Mausdaten einlesen, Disc-Symbol als Mauszeiger
  LOCAL div_i%,div_a%
  '
  RESTORE maus_daten
  glb_disc$=MKI$(0)+MKI$(0)+MKI$(1)
  glb_disc$=glb_disc$+MKI$(0)+MKI$(1)
  FOR div_i%=1 TO 32
    READ div_a%
    glb_disc$=glb_disc$+MKI$(div_a%)
  NEXT div_i%
  glb_disc$=glb_disc$+CHR$(0)
  '
maus_daten:
  DATA 65535,65535,65535,65535,65535,65535,65535,65535,65535,65535,65535,65535
  DATA 65535,65535,65535,65535,65535,65529,65529,65535
  DATA 65535,65535,65535,65535,65535,63519,64287,64287,64287,64287,30751,16382
  '
RETURN
> PROCEDURE error
  '
  LOCAL ret|,error_a%,error_a$
  '
  ' *** Maus auf Pfeil
  ~GRAF_MOUSE(0,0)
  '
  IF ERR=-13
    ALERT 1,"Die Diskette ist|schreibgeschtzt!",1,glb_ok$,dummy&
  ELSE
    error_alert$="Schwerwiegender Fehler!|"
    error_alert$=error_alert$+"Fehler Nummer: "+STR$(ERR)+"|"
    VOID FRE(0)                            ! Garbage Collection
    error_alert$=error_alert$+"Int. Speicher: "+STR$(FRE(0)\1024)+" kB"+"|"
    error_alert$=error_alert$+"Ext. Speicher: "+STR$(INT(FN mfree))+" kB"
    ALERT 3,error_alert$,1,glb_ok$,dummy|
    '
    '  error_a$="Fehler Nummer "+STR$(ERR)
    ' ALERT 1,"Fehlerbeschreibung:|"+error_a$,1,glb_ok$,dummy|
    '
    ALERT 2,"Weiter im Programm ?",2,"ja|nein",ret|
    IF ret|=1
      ' --- Programm weiter ausfhren
      ON ERROR GOSUB error                 ! n„chstes Mal wieder diese Prozedur
      RESUME error_resume_ziel             ! weiter bei Anfang
      '
    ELSE
      '
      IF acc!
        ~EVNT_TIMER(-1)                  ! ACC beendet man nicht
      ELSE
        @rsc_ausgang
      ENDIF
    ENDIF
  ENDIF
  '
RETURN
' ###########################################################################
> PROCEDURE rsc_ausgang
  '
  ' Programmende
  '
  '
  IF NOT acc!
    ' *****************
    ~RSRC_FREE()
    ' *****************
    END
  ELSE
    DO
      ~EVNT_TIMER(-1)
    LOOP
  ENDIF
  '
RETURN
> PROCEDURE rsc_init
  '
  '
  ' RSC erst im Applikationsverz. suchen
  ret!=RSRC_LOAD(path$+glb_rsc_file$)
  IF ret!=FALSE
    ret!=RSRC_LOAD(glb_rsc_file$)
    IF ret!=FALSE
      ~FORM_ALERT(1,"[3][PSION-FT:|Resourcefile "+glb_rsc_file$+" |nicht gefunden!][Abbruch]")
      IF acc!
        DO
          ~EVNT_TIMER(-1)
        LOOP
      ELSE
        '
        END
        '
      ENDIF
    ENDIF
  ENDIF
  ~RSRC_GADDR(0,maindial%,glb_maindial_adr%)
  ~RSRC_GADDR(0,help1%,glb_help_adr1%)
  ~RSRC_GADDR(0,help2%,glb_help_adr2%)
  ~RSRC_GADDR(0,help3%,glb_help_adr3%)
  ~RSRC_GADDR(0,help4%,glb_help_adr4%)
  ~RSRC_GADDR(0,iconbox%,glb_iconbox_adr%)
  '
RETURN
' ###########################################################################
> PROCEDURE rsrc_obtxt_set(rsrc_o.%,rsrc_l.%,rsrc_t.$)
  '
  LOCAL rsrc_ad%,rsrc_ted%,rsrc_n%,rsrc_a%
  ~RSRC_GADDR(2,rsrc_o.%,rsrc_ad%)
  rsrc_ted%=LPEEK(rsrc_ad%)
  FOR rsrc_n%=0 TO rsrc_l.%-1
    rsrc_a%=ASC(MID$(rsrc_t.$,rsrc_n%+1,1))
    POKE rsrc_ted%+rsrc_n%,rsrc_a%
  NEXT rsrc_n%
RETURN
> FUNCTION rsrc_obstate_get(rsrc_o.%)
  '
  LOCAL rsrc_ad%
  ~RSRC_GADDR(1,rsrc_o.%,rsrc_ad%)
  RETURN DPEEK(rsrc_ad%+10)
ENDFUNC
' ######### Dialoge
> PROCEDURE main_dialog
  '
  LOCAL rsc_object%,rsc_object_h%
  LOCAL ret|
  LOCAL on&,off&,dis&
  '
  ' --- Anfangswerte setzen:
  '
  ' --- Button-Flags
  off&=&H0
  on&=off&+1
  dis&=off&+8
  '
  message("",FALSE)
  show_or_hide_box(glb_maindial_adr%,0)   ! Box 1 zeichnen
  '
  REPEAT
    '
    ~OBJC_DRAW(glb_maindial_adr%,msg_box%,2,glb_x1&,glb_y1&,glb_w1&,glb_h1&)  ! Formular 1 zeichnen
    '
    rsc_object%=FORM_DO(glb_maindial_adr%,0)      ! Formular 1 behandeln
    m_msg$=""
    '
    SELECT rsc_object%
    CASE bfhelp%,btxd%,brxd%,bmkdir%,bshow%,bdelete%,bverify%
      '
      show_or_hide_box(glb_maindial_adr%,1)   ! Box 1 l”schen
      '
      SELECT rsc_object%
      CASE bfhelp%
        show_help
      CASE btxd%
        senden
      CASE brxd%
        empfangen
        '
      CASE bmkdir%
        f_msg$="Ordner anlegen"
        @fileselect(f_msg$,path$+"*.*","",file$)  ! Zieldatei ausw„hlen
        IF file$<>"" AND RIGHT$(file$)<>"\"
          @file_exist(file$,ret!)
          IF NOT ret!
            MKDIR file$
            m_msg$="Ordner wurde angelegt."
          ELSE
            m_msg$="Ordner NICHT angelegt."
          ENDIF
        ENDIF
      CASE bshow%
        f_msg$="Datei Info"
        @fileselect(f_msg$,path$+"*.*","",file$)  ! Zieldatei ausw„hlen
        IF file$<>""
          @file_exist(file$,ret!)
          IF ret!
            ' so muž laut Atari die Dateil„nge ermittelt werden
            OPEN "i",#1,file$
            filelen%=LOF(#1)
            CLOSE #1
            '
            m_msg$="Dateil„nge: "+STR$(filelen%)+" Bytes"
            '
          ENDIF
        ENDIF
      CASE bdelete%
        f_msg$="Datei l”schen"
        @fileselect(f_msg$,path$+"*.*","",file$)  ! Zieldatei ausw„hlen
        IF file$<>""
          @file_exist(file$,ret!)
          IF ret!
            KILL file$
            m_msg$="Datei wurde gel”scht."
          ELSE
            m_msg$="Datei nicht gel”scht."
          ENDIF
        ENDIF
      CASE bverify%
        f_msg$="Datei vergleichen"
        @fileselect(f_msg$,path$+"*.*","",file$)  ! Zieldatei ausw„hlen
        m_msg$="Gibt's noch nicht!"
        '
      ENDSELECT
      '
      show_or_hide_box(glb_maindial_adr%,0)   ! Box 1 zeichnen
      '
    CASE binfo%
      '
      alert$="Dies ist eine Test-Version!|"
      alert$=alert$+"Erwarten Sie also nix! :-("
      ALERT 1,alert$,1,glb_ok$,dummy&
      '
    CASE bup%
      '
      IF glb_baud&>0
        DEC glb_baud&
      ENDIF
      rs_232
      ~OBJC_DRAW(glb_maindial_adr%,bbaud%,2,glb_x1&,glb_y1&,glb_w1&,glb_h1&)  ! Formular 1 zeichnen
      ~OBJC_DRAW(glb_maindial_adr%,bup%,2,glb_x1&,glb_y1&,glb_w1&,glb_h1&)  ! Formular 1 zeichnen
      '
    CASE bdown%
      '
      IF glb_baud&<15
        INC glb_baud&
      ENDIF
      rs_232
      ~OBJC_DRAW(glb_maindial_adr%,bbaud%,2,glb_x1&,glb_y1&,glb_w1&,glb_h1&)  ! Formular 1 zeichnen
      ~OBJC_DRAW(glb_maindial_adr%,bdown%,2,glb_x1&,glb_y1&,glb_w1&,glb_h1&)  ! Formular 1 zeichnen
      '
    CASE bfcancel%
      '
    DEFAULT
      ALERT 1,"Diese Funktion ist noch|nicht implementiert!",1,glb_ok$,dummy|
    ENDSELECT
    '
    message(m_msg$,FALSE)
    '
    ' --- Exit-Button
    ~OBJC_OFFSET(glb_maindial_adr%,0,glb_x1&,glb_y1&) !Box kann verschoben sein
    IF rsc_object%=binfo%
      ' dieses ist Shadowed+Outlined
      ~OBJC_CHANGE(glb_maindial_adr%,rsc_object%,0,glb_x1&,glb_y1&,glb_w1&,glb_h1&,48,1)
    ELSE
      ~OBJC_CHANGE(glb_maindial_adr%,rsc_object%,0,glb_x1&,glb_y1&,glb_w1&,glb_h1&,0,1)
    ENDIF
    '
  UNTIL rsc_object%=bfcancel%
  '
  show_or_hide_box(glb_maindial_adr%,1)   ! Box 1 l”schen
  '
RETURN
> PROCEDURE show_help
  '
  help_1
  '
RETURN
> PROCEDURE help_1
  '
  show_or_hide_box(glb_help_adr1%,2)          !Box 2 zeicnen
  '
  rsc_object_h%=FORM_DO(glb_help_adr1%,0)  ! Formular behandeln
  ~OBJC_OFFSET(glb_help_adr1%,0,glb_x2&,glb_y2&) !Box kann verschoben sein
  ~OBJC_CHANGE(glb_help_adr1%,rsc_object_h%,0,glb_x2&,glb_y2&,glb_w2&,glb_h2&,0,1)
  '
  show_or_hide_box(glb_help_adr1%,3)               ! Box 2 l”schen
  '
  SELECT rsc_object_h%
  CASE bforw1%
    help_2
  CASE bback1%
  ENDSELECT
  '
RETURN
> PROCEDURE help_2
  '
  show_or_hide_box(glb_help_adr2%,2)          !Box 2 zeicnen
  '
  rsc_object_h%=FORM_DO(glb_help_adr2%,0)  ! Formular behandeln
  ~OBJC_OFFSET(glb_help_adr2%,0,glb_x2&,glb_y2&) !Box kann verschoben sein
  ~OBJC_CHANGE(glb_help_adr2%,rsc_object_h%,0,glb_x2&,glb_y2&,glb_w2&,glb_h2&,0,1)
  '
  show_or_hide_box(glb_help_adr2%,3)               ! Box 2 l”schen
  '
  SELECT rsc_object_h%
  CASE bforw1%
    help_3
  CASE bback1%
    help_1
  ENDSELECT
  '
RETURN
> PROCEDURE help_3
  '
  show_or_hide_box(glb_help_adr3%,2)          !Box 2 zeicnen
  '
  rsc_object_h%=FORM_DO(glb_help_adr3%,0)  ! Formular behandeln
  ~OBJC_OFFSET(glb_help_adr3%,0,glb_x2&,glb_y2&) !Box kann verschoben sein
  ~OBJC_CHANGE(glb_help_adr3%,rsc_object_h%,0,glb_x2&,glb_y2&,glb_w2&,glb_h2&,0,1)
  '
  show_or_hide_box(glb_help_adr3%,3)               ! Box 2 l”schen
  '
  SELECT rsc_object_h%
  CASE bforw1%
    help_4
  CASE bback1%
    help_2
  ENDSELECT
  '
RETURN
> PROCEDURE help_4
  '
  show_or_hide_box(glb_help_adr4%,2)          !Box 2 zeicnen
  '
  rsc_object_h%=FORM_DO(glb_help_adr4%,0)  ! Formular behandeln
  ~OBJC_OFFSET(glb_help_adr4%,0,glb_x2&,glb_y2&) !Box kann verschoben sein
  ~OBJC_CHANGE(glb_help_adr4%,rsc_object_h%,0,glb_x2&,glb_y2&,glb_w2&,glb_h2&,0,1)
  '
  show_or_hide_box(glb_help_adr4%,3)               ! Box 2 l”schen
  '
  SELECT rsc_object_h%
  CASE bforw1%
    '
  CASE bback1%
    help_3
  ENDSELECT
  '
RETURN
'
> PROCEDURE show_iconbox
  '
  ' Bestimmt neue Gr”že der Box aufgrund der Icongr”že (aufl”sungsabh„ngig!)
  ' und gibt diese samt Icon unten rechts aus
  '
  ' Das Icon als erstes ausgeben, da es sonst bei geringer Aufl”sung
  ' die Hauptdialogbox verdecken k”nnte
  '
  LOCAL lx&,ly&         ! neue Koordinaten
  '
  ' muž das sein? Kann aber wohl nicht schaden
  ~FORM_CENTER(glb_iconbox_adr%,glb_x3&,glb_y3&,glb_w3&,glb_h3&)
  '
  ' --- Adresse der ICONBLK-Struktur holen
  ~RSRC_GADDR(1,t5obj%+icon%,glb_icon_adr%)
  ' --- Koordinaten ermitteln
  ~FORM_CENTER(glb_icon_adr%,icon_x&,icon_y&,icon_w&,icon_h&)
  '
  ' --- Iconbox verschieben und ausgeben
  lx&=desk_w&+desk_x&-icon_w&-16  ! neue x-Koordiante fr Icon bestimmen
  ly&=desk_h&+desk_y&-icon_h&-16  ! neue y-Koordiante fr Icon bestimmen
  DPOKE glb_icon_adr%+16,lx&
  DPOKE glb_icon_adr%+18,ly&
  '
  icon_x&=lx&
  icon_y&=ly&
  ~FORM_DIAL(0,0,0,0,0,icon_x&,icon_y&,icon_w&,icon_h&) ! Bildschirmbereich reservieren
  ~OBJC_DRAW(glb_icon_adr%,0,2,icon_x&,icon_y&,icon_w&,icon_h&)  ! Object ausgeben
  '
RETURN
> PROCEDURE hide_iconbox
  '
  ~FORM_DIAL(3,0,0,0,0,icon_x&,icon_y&,icon_w&,icon_h&) ! Box weg
  '
RETURN
> PROCEDURE show_or_hide_box(adr.%,mode.&)
  ' mode 0 : Hauptbox zeichen
  ' mode 1 : Hauptbox l”schen
  ' mode 2 : eine Hilfebox zeichen
  ' mode 3 : eine Hilfebox l”schen
  ' mode 4 : Copyrightbox zeichnen
  ' mode 5 : Copyrightbox zeichnen
  ' -------------------------------------------------------------------------
  ' um Probleme zu vermeiden, alle WIND_UPDATE-abh„ngigen Grafikausgaben
  ' in dieser PROC zwischen BEG_UPDATE und END_UPDATE durchfhren
  ' -------------------------------------------------------------------------
  '
  ~WIND_GET(0,4,desk_x&,desk_y&,desk_w&,desk_h&)! Ausmaže des Desktop holen (WIND 0)
  '
  '
  ' wann immer ein Dialog ausgegeben wird...
  SELECT mode.&
  CASE 0,2,4
    '    beg_update
    show_iconbox
  ENDSELECT
  '
  '
  SELECT mode.&
  CASE 0        ! Box 1 zeichnen
    '
    ~FORM_CENTER(adr.%,glb_x1&,glb_y1&,glb_w1&,glb_h1&)
    ~FORM_DIAL(0,0,0,0,0,glb_x1&,glb_y1&,glb_w1&,glb_h1&) ! Bildschirmbereich reservieren
    beg_update
    ~OBJC_DRAW(adr.%,0,2,glb_x1&,glb_y1&,glb_w1&,glb_h1&)  ! Formular 1 zeichnen
    '
  CASE 1        ! Box 1 l”schen
    ~FORM_CENTER(adr.%,glb_x1&,glb_y1&,glb_w1&,glb_h1&)
    ~FORM_DIAL(3,0,0,0,0,glb_x1&,glb_y1&,glb_w1&,glb_h1&)
    end_update
    '
  CASE 2        ! Box 2 zeichen
    '
    ~FORM_CENTER(adr.%,glb_x2&,glb_y2&,glb_w2&,glb_h2&)
    ~FORM_DIAL(0,0,0,0,0,glb_x2&,glb_y2&,glb_w2&,glb_h2&)
    beg_update
    ~OBJC_DRAW(adr.%,0,2,glb_x2&,glb_y2&,glb_w2&,glb_h2&)
  CASE 3        ! Box 2 l”schen
    ~FORM_CENTER(adr.%,glb_x2&,glb_y2&,glb_w2&,glb_h2&)
    ~FORM_DIAL(3,0,0,0,0,glb_x2&,glb_y2&,glb_w2&,glb_h2&)   ! alte Dialogbox weg
    end_update
    '
    ' CASE is hier nich:
    '           ! Box 3 ist das PSION-FT-Icon
    '
  CASE 4        ! Box 4 zeichen
    '
    ~FORM_CENTER(adr.%,glb_x4&,glb_y4&,glb_w4&,glb_h4&)
    ~FORM_DIAL(0,0,0,0,0,glb_x4&,glb_y4&,glb_w4&,glb_h4&)
    ' ~WIND_GET(0,4,desk_x&,desk_y&,desk_w&,desk_h&)! Ausmaže des Desktop holen (WIND 0)
    ' ~FORM_DIAL(0,0,0,0,0,desk_x&,desk_y&,desk_w&,desk_h&)
    ~OBJC_DRAW(adr.%,0,7,glb_x4&,glb_y4&,glb_w4&,glb_h4&)
    '
    '
  CASE 5        ! Box 4 l”schen
    ~FORM_CENTER(adr.%,glb_x4&,glb_y4&,glb_w4&,glb_h4&)
    ~FORM_DIAL(3,0,0,0,0,glb_x4&,glb_y4&,glb_w4&,glb_h4&)   ! alte Dialogbox weg
    '
  ENDSELECT
  '
  '
  ' wann immer ein Dialog entfernt wird...
  SELECT mode.&
  CASE 1,3,5
    hide_iconbox
    '
    '    end_update
    '
  ENDSELECT
  '
  '
RETURN
'
> PROCEDURE message(msg.$,draw!)
  '
  LOCAL adr%
  '
  ' Die Message-Box bietet 30 Zeichen Text
  rsrc_obtxt_set(5,30,msg.$)
  IF draw!
    ~OBJC_DRAW(glb_maindial_adr%,msg_box%,2,glb_x1&,glb_y1&,glb_w1&,glb_h1&)  ! Formular 1 zeichnen
  ENDIF
RETURN
'
> PROCEDURE beg_update
  ~WIND_UPDATE(1)                     ! BEG_UPDATE
  ~WIND_UPDATE(3)                     ! BEG_MCRTL: die Maus ist jetzt meine
  '
  INC windup_count&
  '  debug(STR$(windup_count&))
  '
  IF windup_count&=2
    ALERT 3,"Fehler (+) bei WIND_UPDATE!",1,glb_ok$,dummy&
  ENDIF
RETURN
> PROCEDURE end_update
  ~WIND_UPDATE(2)                     ! END_MCRTL: ich gebe die Maus frei
  ~WIND_UPDATE(0)                     ! END_UPDATE
  '
  DEC windup_count&
  ' debug(STR$(windup_count&))
  '
  IF windup_count&=-1
    ALERT 3,"Fehler (-) bei WIND_UPDATE!",1,glb_ok$,dummy&
  ENDIF
RETURN
'
> PROCEDURE file_exist(file.$,VAR ret!)
  '
  ' die GFA-Funktion EXIST kann nicht in ACC's verwendet werden:
  ' --> nach Endes des ACC und Start eines PRG: Systemabsturz :-(
  '
  LOCAL handle&,f%
  '
  ' --- mit Fopen die Datei ”ffnen
  file.$=file.$+CHR$(0)
  f%=VARPTR(file.$)
  handle&=GEMDOS(61,L:f%,W:0)
  '  ALERT 1,STR$(handle&),1,"OK",d
  IF handle&>=0
    ' --- wichtig: ge”ffnete Datei wieder schliežen, also das Handle freigeben
    ~GEMDOS(62,handle&)
    ret!=TRUE
  ELSE
    ret!=FALSE
  ENDIF
RETURN
'
> PROCEDURE fileselect(title$,inpath$,insel$,VAR b$)
  ' Fileselect-Aufruf fr TOS 1.4
  ' FILESELECT #title$,inpath$,insel$,b$ !ab GFA-Basic 3.04
  '
  '  ~FORM_DIAL(0,0,0,0,0,desk_x&,desk_y&,desk_w&,desk_h&)
  '
  inpath$=inpath$+CHR$(0)+SPACE$(37)
  insel$=insel$+CHR$(0)+SPACE$(12)
  title$=LEFT$(title$,30)+CHR$(0)
  DPOKE GCONTRL+2,0
  DPOKE GCONTRL+4,2
  DPOKE GCONTRL+6,3
  DPOKE GCONTRL+8,0
  ADDRIN(0)=VARPTR(inpath$)
  ADDRIN(1)=VARPTR(insel$)
  ADDRIN(2)=VARPTR(title$)
  ' SHOWM
  IF WORD{{GB+4}}>=&H130 AND WORD{{GB+4}}<>&H200 ! global(0)
    '          ! BETA-TOS             ! GEM 2.0
    ' ist aber in einem Disketten-TOS falsch angegeben
    $U
    GEMSYS 91   ! FSEL_EXINPUT()
    $U
  ELSE
    $U
    GEMSYS 90   ! FSEL_INPUT()      bis Blitter-TOS 1.2
    $U
  ENDIF
  inpath$=CHAR{V:inpath$}
  insel$=CHAR{V:insel$}
  IF GINTOUT(1)=1 ! OK-Button
    b$=UPPER$(LEFT$(inpath$,INSTR(inpath$,"*")-1)+insel$)
  ELSE
    b$=""
  ENDIF
  '
  '  ~FORM_DIAL(3,0,0,0,0,desk_x&,desk_y&,desk_w&,desk_h&)
  '
  ' SHOWM
RETURN
> PROCEDURE debug(a.$)
  ALERT 1,a.$,1,"Debug",x&
RETURN
'
> PROCEDURE rsc_data
  '
  ' Baumindizes
  '
  t0obj%=0
  t1obj%=17
  t2obj%=39
  t3obj%=61
  t4obj%=83
  t5obj%=105
  '
  ' resource set indices for PSION_FT
  '
  LET maindial%=0 ! form/dialog
  LET bfcancel%=1 ! BUTTON in tree MAINDIAL
  LET bfhelp%=3 ! BOXTEXT in tree MAINDIAL
  LET binfo%=4 ! BOXTEXT in tree MAINDIAL
  LET bdown%=5 ! BOXTEXT in tree MAINDIAL
  LET bup%=6 ! BOXTEXT in tree MAINDIAL
  LET bbaud%=7 ! BOXTEXT in tree MAINDIAL
  LET btxd%=8 ! BUTTON in tree MAINDIAL
  LET brxd%=9 ! BUTTON in tree MAINDIAL
  LET bshow%=12 ! BUTTON in tree MAINDIAL
  LET bdelete%=13 ! BUTTON in tree MAINDIAL
  LET bverify%=14 ! BUTTON in tree MAINDIAL
  LET bmkdir%=15 ! BUTTON in tree MAINDIAL
  LET msg_box%=16 ! BOXTEXT in tree MAINDIAL
  '
  LET help1%=1 ! form/dialog
  LET bend1%=1 ! BUTTON in tree HELP1
  LET bback1%=20 ! BUTTON in tree HELP1
  LET bforw1%=21 ! BUTTON in tree HELP1
  '
  LET help2%=2 ! form/dialog
  LET bend2%=1 ! BUTTON in tree HELP2
  LET bback2%=20 ! BUTTON in tree HELP2
  LET bforw2%=21 ! BUTTON in tree HELP2
  '
  LET help3%=3 ! form/dialog
  LET bend3%=1 ! BUTTON in tree HELP3
  LET bback3%=20 ! BUTTON in tree HELP3
  LET bforw3%=21 ! BUTTON in tree HELP3
  '
  LET help4%=4 ! form/dialog
  LET bend4%=1 ! BUTTON in tree HELP4
  LET bback4%=20 ! BUTTON in tree HELP4
  LET bforw4%=21 ! BUTTON in tree HELP4
  '
  LET iconbox%=5 ! form/dialog
  LET icon%=1 ! ICON in tree ICONBOX
  '
  '
RETURN
'